(define-module (lisp namespace)
  ;;;
  ;;; NAMESPACES
  ;;; Namespaces are parsers that resolve references to global variables.
  ;;; If the s-expression being parsed isn't a symbol, they call their base
  ;;; method, which is the default parser method above.
  ;;;
  ;;; Namespaces come in four flavors, all of which have the parent class
  ;;; NamespaceBase.  These are:
  ;;; - (Real) Namespaces
  ;;;   These contain normal global variables in Meta
  ;;; - Packages
  ;;;   These are normal Meta.Namespaces that are associated with a file that
  ;;;   gets autoloaded upon first reference to the namespace.
  ;;; - PackageDirectory's
  ;;;   These are namespaces that has a set of "fake" global variables
  ;;;   to all the files in a directory.  When one of the variables is looked
  ;;;   up, it creates a Package object to correspond to the file and puts it
  ;;;   in the corresponding variable.
  ;;; - NativeNamespaces
  ;;;   These present the underlying CLR type hierarchy to Meta as if it were
  ;;;   an namespace with a set of "fake" global variables.
  ;;;

  (define-class (namespace-ref nr-name) i-object-reference
    ("[Serializable]")
    (define nr-name "name" (public string) null)
    (define (get-real-object nr context)
      (resolve-namespace (nr-name nr))))

  (define-class namespace-base (parser "System.Runtime.Serialization.ISerializable")
    ("[Serializable]")
    ;;;
    ;;; Instance variables
    ;;;
    (define namespace-name "name" (public object) null)
    (define (to-string ns) (public override string)
      (to-string (namespace-name ns)))

    (define (imports ns) (public virtual property ilist)
      (cast ilist (new-array namespace 0)))

    (define (exports ns) (public virtual property idictionary)
      (return null))

    (define bindings (public hashtable) (hashtable))

    (define (clr-namespace ns) "CLRNamespace" (public virtual property string)
      (let ((n (namespace-name ns)))
	(cond ((null? n)
	       "")
	      ((is? n symbol)
	       (pname (cast symbol n)))
	      ((is? n string)
	       (cast string n))
	      (else
	       ""))))

    (define (get-object-data ns info context)
      ;(public "[SecurityPermissionAttribute(SecurityAction.Demand,SerializationFormatter=true)]")
      (add-value info "name" (clr-namespace ns))
      (set-type info (type->clr-type namespace-ref)))

    ;;;
    ;;; Abstract methods
    ;;;
    (define (import! n (namespace-base import)) "Import" (public abstract void)
      #f)
    (define (export! n (symbol name)) "Export" (public abstract void)
      #f)

    ;; Return the global variable with the name sym, creating if necessary.
    (define (lookup n
		    (symbol sym)
		    (boolean search-imports)
		    (boolean create)
		    (boolean include-private))
      (public abstract global-variable)
      #f)

    ;;;
    ;;; Parsing
    ;;; If it's a symbol, look it up, otherwise send it to the default parser.
    ;;;
    (define (parse n tuple subparser)
      (let ((s (as tuple symbol)))
	(if (or (null? s)
		(is? s keyword))
	    (parse base tuple subparser)
	    (lookup n s #t #t #t))))

    ;;;
    ;;; Shared methods
    ;;;

    ;; Return the current value of the global variable with
    ;; the specified name, if it exists.
    (define (check-binding n symbol-name) (public object)
      (if (eq? symbol-name null)
	  null
	  (let ((sym (maybe-intern symbol-name)))
	    (if (not (eq? sym null))
		(let ((probe (lookup n sym #t #f #t)))
		  (if (not (eq? probe null))
		      (value probe)
		      null))
		null))))

    ;; Same, but only return non-null if the binding is a function
    ;; (i.e. procedure). 
    (define (check-fbinding n symbol-name) (public procedure)
      (if (eq? symbol-name null)
	  null
	  (let ((binding (check-binding n symbol-name)))
	    (if (and (not (eq? binding null))
		     (is? binding procedure))
		(cast procedure binding)
		null))))

    ;; Defines value as a constant in the specified name in the namespace.
    (define (define-in-namespace! n (string symname) (object new-value))
      "Define"
      (public void)
      (let ((v (lookup n (intern symname)
		       #f #t #t)))
	(set-value! v new-value null)
	(export! n (vname v))
	(set (constant? v) #t)
	(when (is? new-value procedure)
	  (let ((proc (cast procedure new-value)))
	    (when (not (eq? (documentation-kluge (cast i-documentable proc)) null))
	      (set (variable-documentation v)
		   (documentation-kluge (cast i-documentable proc))))))))

    ;; Same as above, but allows a documentation string.
    (define (define-with-doc-in-namespace n
	      (string symname)
	      (object new-value)
	      (string doc-string))
      "Define"
      (public void)
      (define-in-namespace! n symname new-value)
      (let ((v (lookup n (intern symname) #f #t #t)))
	(set (variable-documentation v) doc-string))))

  ;;;
  ;;; The normal Namespace class, i.e. a global environment the user can
  ;;; make bindings in.
  ;;;
  (define-class (namespace namespace-name) namespace-base
    ("[Serializable]")
    ;;;
    ;;; Static stuff
    ;;;
    (define current-namespace-changed "CurrentNamespaceChanged" (public static event void-thunk) null)
    (define m-root-namespace (static readonly namespace)
      (new namespace "Meta.RootNamespace"))
    (define (root-namespace) (public static property namespace)
      m-root-namespace)
    (define m-user-namespace (static readonly namespace)
      (new namespace "Meta.UserNamespace"))
    (define (user-namespace) (public static property namespace)
      m-user-namespace)
    (define current-namespace-fluid (public static fluid)
      (new fluid m-root-namespace))
    (define (current-namespace) (public static property namespace)
      (cast namespace (fluid-value current-namespace-fluid)))
    (define (set-namespace! (namespace ns)) "SetCurrentNamespace" (public void)
      (set (fluid-value current-namespace-fluid)
	   ns)
      (note-namespace))
    (define (note-namespace) (public static void)
      (unless (null? current-namespace-changed)
	(call-current-namespace-changed)))
    (define warnings "Warnings" (public idictionary) null)
    (define (has-warnings n) (public property boolean)
      (and (not (null? (warnings n)))
	   (> (icollection-count (keys (warnings n)))
	      0)))
	  

    (define fluid-table (public readonly hashtable) (hashtable))

    (define (make-standard-namespace (symbol name)) (public static namespace)
      (let ((n (new namespace name)))
	(import! n root-namespace-kluge)
	n))

    ;; Make a global variable with the specified name and value.
    (define (define! (string symname) (object new-value)) "DefineManifestConstant"
      (public static void)
      (define-in-namespace! default-namespace-kluge symname new-value))

    (define (defin--with-doc
	      (string symname)
	      (object new-value)
	      (string doc-string))
      "DefineManifestConstant"
      (public static void)
      (define-with-doc-in-namespace default-namespace-kluge symname new-value doc-string))

    ;;;
    ;;; Instance variables
    ;;;
    (define imported-namespaces (private array-list) (array-list))
    (define exported-variables (private hashtable) (hashtable))
    (define cached-bindings (private hashtable) (hashtable))

    (define (initialize! ns) (public void)
      (set (bindings ns) (hashtable)))


    ;;;
    ;;; Import/export
    ;;;
    (define (export! n (symbol name))
      (enter-monitor n)
      (let ((v (lookup n name #t #t #t)))
	(set (gethash (exported-variables n)
		      v)
	     v))
      (exit-monitor n))

    (define (import! n (namespace-base import))
      (enter-monitor n)
      (unless (or (eq? n import)
		  (contains? (imported-namespaces n)
			     import))
	(insert (imported-namespaces n)
		0
		import))
      ;; Shadow any bindings of n that have the same names as exports of import
      (let ((exps (exports import)))
	(unless (null? exps)
	  (let ((e (get-enumerator exps)))
	    (while (move-next e)
	      (remove (bindings n)
		      (vname (cast global-variable
				   (idictionaryenumerator-value e))))
	      (remove (cached-bindings n)
		      (vname (cast global-variable
				   (idictionaryenumerator-value e))))))))
      (exit-monitor n))

    (define (imports ns) (public override property ilist)
      (cast ilist (imported-namespaces ns)))

    (define (exports ns) (public override property idictionary)
      (cast idictionary exported-variables))

    ;;;
    ;;; Binding management
    ;;;

    ;; Return the global variable with the name sym, if any.
    (define (maybe-lookup n (symbol sym) (boolean imports?))
      (private global-variable)
      (let ((result null)
	    (binding (gethash (cached-bindings n) sym))
	    (i 0))
	;; Check imports, if requested
	(when (and imports?
		   (eq? binding null))
	  ;; Don't keep the namespace locked while we search the imports
	  (exit-monitor n)
	  (while (and (null? result)
		      (< i (count (imported-namespaces n))))
	    (let ((import (cast namespace-base (vector-ref (imported-namespaces n) i))))
	      (let ((v (lookup import sym #t #f #f)))
		(unless (null? v)
		  (set result v))))
	    (set i (+ i 1)))
	  (unless (null? result)
	    (set (gethash (cached-bindings n)
			  sym)
		 result))
	  ;; Now we have to relock
	  (enter-monitor n))
	;; Now return the binding or import, if applicable
	(cond ((and (not imports?)
		    (not (null? binding))
		    (not (eq? (gv-namespace binding) n)))
	       ;; Accidentally got a cached binding.
	       null)
	      ((eq? result null)
	       binding)
	      (else
	       result))))

    (define (create-binding! n (symbol sym)) (private global-variable)
      (let ((var (global-variable sym n)))
	(set (gethash (bindings n) sym)
	     var)
	(set (gethash (cached-bindings n) sym)
	     var)
	var))

    ;; Return the global variable with the name sym, creating if necessary.
    (define (lookup n sym search-imports? create? include-private?)
      (enter-monitor n)
      (let ((probe (maybe-lookup n sym search-imports?))
	    (result null))
	(cond ((and (eq? probe null)
		    create?)
	       (set result (create-binding! n sym)))
	      ((or include-private?
		   (null? probe))
	       (set result probe))
	      (else
	       ;; We weren't supposed to include private variables, so
	       ;; make sure whatever we got is in our export list.
	       (set result
		    (gethash (exported-variables n)
			     probe))))
	(exit-monitor n)
	;; Done; return the result.
	result))))